Network CD 2/Network CD - Volume 2.iso/programs/dopus/arexx/lhadir.dopus

Text File | 1995-01-22 | 21.2 KB | 885 lines

/*
  $VER: LhADir.dopus 1.9 (2.9.94)
  Copyright © 1993-1994 by EAV Productions International
  Placed in the public domain. No restrictions on distribution or usage.

  LhADir.dopus is an ARexx script for Directory Opus that allows you to show
  the contents of LhA archives in a DOpus window and operate on the files and
  directories inside an archive as if it is a normal directory.

  Possible arguments (not case sensitive) for LhADir.dopus:

   GETDIR, BROWSE, PARENT, ROOT, DELETE, COPY, MOVE, MAKEDIR, GETSIZES,
   READ, ANSIREAD, HEXREAD, SHOW, PLAY, LOOPPLAY, PRINT, ICONINFO, RUN,
   VERSION, UNDMS, MULTIVIEW, AMIGAGUIDE, VIEWTEK, RETINADISPLAY.
*/

signal on syntax    /* intercept syntax errors */
options results        /* need results */
options failat 21    /* external commands are allowed return code 20 */
numeric digits 10    /* needed for convertdate routine */
lf='a'x            /* ascii code for linefeed */

parse arg command portname . '"' selected '"'
upper command
if portname~=='' then
   address(portname)
else
   portname=address()
parse var portname '.' port  /* port number */

busy on            /* busy mouse pointer on */
status 3        /* get active window */
win=result
status 9 win        /* get number of selected entries */
entries=result
checkabort        /* reset abort flag */

call checkconfig
call checklhadir(win)

if selected~=='' then do
   filetype=-1
   entries=1
   end
else
   if entries>0 then
      call getnextone

topline=""
listlha=0
notmove=command~='MOVE'
if pos('|'command'|','|GETDIR|BROWSE|PARENT|ROOT|DELETE|COPY|MOVE|MAKEDIR|GETSIZES|')>0 then
   interpret 'call do'command
else do
   n=entries
   async=pos('|'command'|','|READ|ANSIREAD|HEXREAD|')>0
   internal=async|pos('|'command'|','|SHOW|PLAY|LOOPPLAY|PRINT|ICONINFO|RUN|')>0
   if entries=0|async|(internal&~(lhadir&entries>0))|command='VERSION' then
      n=1
   thisfile=''

   do i=1 to n
      checkabort
      if result then
     call quitit "Aborted..."

      if entries>0 then
     if lhadir then do
        if filetype>0 then
           call quitit "Error, cannot view directories."
        address command 'LhA e -q -x2 -Qo "'patch2(lhafile)'" T: "'patch(lhasubdir||selected)'"'
        if rc>0 then
           call quitit "Error while extracting file."
        thisfile='"T:'selected'"'
        end
     else
        if ~internal then
           thisfile='"'selected'"'

      if internal then do
     interpret '"'command '"'thisfile'""'
     abort=result~=0
     end
      else do
     if ~lhadir&entries>0 then
        thisfile='"'winpath||selected'"'
     query screenname
     if result=0 then
        screenname=portname  /* for compatibility */
     else
        screenname=result

     select  /* external commands */
        when command='VERSION' then
           call version
        when command='UNDMS' then
           call undms
        when command='MULTIVIEW' then
           address command 'MultiView' thisfile 'PUBSCREEN' screenname 'FONTNAME' fontname 'FONTSIZE' fontsize
        when command='AMIGAGUIDE' then
           address command 'AmigaGuide' thisfile 'PUBSCREEN' screenname
        when command='VIEWTEK' then
           address command 'Work:OtherTools/VT >NIL:' thisfile
        when command='RETINADISPLAY' then
           address command 'Work:Retina/RetinaTools/RetinaDisplay' thisfile
        otherwise
           call quitit "Error, LhADir.dopus does not support the command '"command"'."
        end
     abort=0
     end

      busy on
      if lhadir&entries>0 then do
     if async then do
        if ~show('l','rexxsupport.library') then
           call addlib('rexxsupport.library',0,-30)  /* needed for delay() */
        call delay(75)  /* wait a bit before deleting */
        end
     delete '"T:'selected'"'
     busy on
     end
      if thisfile~=='' then do
     selectfile '"'selected'" 0 1'  /* deselect item */
     if topline=="" then
        topline="OK"
     end
      if abort then
     call quitit
      if i<n then
     call getnextone
      end
   end

call quitit topline  /* finished */


dobrowse:
dogetdir:

   if entries>0 then
      if filetype>0 then  /* list a new dir */
     if lhadir then
        lhasubdir=lhasubdir||selected'/'
     else
        winpath=winpath||selected'/'
      else do  /* list an archive file */
     if pos('|'upper(right(selected,4)'|'),'|.LHA|.LZH|.RUN|')=0 then
        call quitit "Error, LhADir.dopus can only list LhA archives."
     if lhadir then do
        request "This is an archive in an archive."lf"Extract it to 'T:' and then list it?"
        uset=result
        if uset then
           destpath='T:'
        else do
           busy on
           status 13 1-win  /* get window path */
           destpath=result
           if result=='' then
          call quitit "Aborted..."
           request "Use the current destination window"lf"'"destpath"' instead?"
           if ~result then
          call quitit "Aborted..."
           end
        busy on
        toptext "Extracting from archive..."
        address command 'LhA e -q -x2 -a -C0 -Qo "'patch2(lhafile)'" "'destpath'" "'patch(lhasubdir||selected)'"'
        if rc>0 then
           call quitit "Error while extracting from archive."
        if ~uset&command='GETDIR' then
           rescan 1-win
        lhafile=destpath||selected
        end
     else
        lhafile=winpath||selected
     lhadir=1
     lhasubdir=''
     listlha=1
     end
   else  /* rescan current dir */
      if lhadir then do
     status 6 win  /* get number of entries */
     listlha=result>0
     end

   if command='BROWSE' then do
      selectfile '"'selected'" 0 1'
      call swapactive
      end
   if lhadir then do
      call showlhadir
      topline="OK"
      end
   else
      status 13 win set '"'winpath'"'
   return


doparent:

   if lhadir&lhasubdir~=='' then do
      cuthere=lastpos('/',lhasubdir,length(lhasubdir)-1)
      lhasubdir=left(lhasubdir,cuthere)
      call showlhadir
      topline="OK"
      end
   else
      parent
   return


doroot:

   if lhadir then do
      cuthere=lastpos('/',lhafile,length(lhafile)-1)
      if cuthere=0 then
     cuthere=lastpos(':',lhafile)
      status 13 win set '"'left(lhafile,cuthere)'"'
      end
   else
      root
   return


dodelete:

   if lhadir then do
      if entries=0 then
     call quitit
      if notmove then do
     if ~askdelete then do
        status 26 set "Delete"
        request "Do you really wish to delete selected entries"lf"from archive?"
        if ~result then
           call quitit "Aborted..."
        busy on
        end
     call getall
     end
      call open('actionfile','T:actionfile'port,'w')
      do i=1 to entries
     if type.i>0 then
        wild='/#?'
     else
        wild=''
     call writeln('actionfile','"'patch(lhasubdir||name.i)||wild'"')
     removefile '"'name.i'" 0'
     end
      call close('actionfile')
      toptext "Deleting from archive..."
      address command 'LhA d -q -Qp -Qo "'patch2(lhafile)'" @T:actionfile'port
      if rc>0 then do
     topline="Error while deleting from archive."
     listlha=1
     call showlhadir
     end
      else do
     topline="OK"
     displaydir
     end
      delete 'T:actionfile'port
      delete 'T:LhADir.list'port  /* archive contents has changed */
      busy on
      end
   else do
      if notmove then
     restore
      delete
      end
   return


domove:
docopy:

   if entries=0 then
      call quitit
   problem=0
   source=winpath
   s_lhadir=lhadir
   s_lhafile=lhafile
   s_lhasubdir=lhasubdir
   call checklhadir(1-win)

   if s_lhadir then do
      if winpath=='' then do
     errortext="No destination directory selected!"
     toptext errortext
     notify errortext
     call quitit
     end
      if lhadir then
     winpath='T:LhADir'port'/'lhasubdir
      call getall
      call lhaextract
      if lhadir then do
     source=winpath
     call lhaadd
     end
      else
     if problem then
        rescan 1-win
     else do
        do i=1 to entries
           fileinfo '"'name.i'" /'
           info.i=result
           end
        call swapactive
        do i=1 to entries
           parse var info.i name '/' size '/' '/' type '/' '/' days '/' seconds '/' comment '/' atts '/'
           if type>0 then
          size=0
           addfile '"'name'"' size type seconds+days*86400 '"'comment'"' atts '0 0'
           end
        displaydir
        call swapactive
        end
      end
   else
      if lhadir then do
     call getall
     call lhaadd
     end
      else do  /* normal copy/move */
     restore
     if notmove then
        copy
     else
        move
     end

   if (s_lhadir|lhadir)&~notmove&~problem then do
      lhadir=s_lhadir
      lhafile=s_lhafile
      lhasubdir=s_lhasubdir
      checkabort
      if result then
     call quitit "Aborted..."
      call dodelete
      end
   return


domakedir:

   getstring '"Enter directory name or archive name.lha"'
   dirtomake=result
   if rc|dirtomake=='' then
      call quitit
   now=date('i')*86400+time('s')
   if lhadir then do  /* create empty dir in archive */
      call createdirs dirtomake'/'
      address command 'LhA a -q -e -r -Qo "'patch2(lhafile)'" T:LhADir'port'/' '"'patch(lhasubdir||dirtomake)'"'
      if rc>0 then
     topline="Error while adding to archive."
      else do
     topline="Directory created."
     addfile '"'dirtomake'" 0 1' now '"" ----RWED 0 1'
     end
      delete 'T:LhADir'port
      delete 'T:LhADir.list'port
      busy on
      end
   else do
      if upper(right(dirtomake,4))=='.LHA' then  /* create new archive */
     if open('emptyarchive',winpath||dirtomake,'w') then do
        call writech('emptyarchive','0'x)
        call close('emptyarchive')
        topline="Empty archive created."
        addfile '"'dirtomake'" 1 -1' now '"" ----RWED 0 1'
        end
     else
        topline="Error creating archive."
      else do  /* normal makedir */
     restore
     makedir '"'dirtomake'"'
     end
      end
   return


dogetsizes:

   if lhadir then do
      status 6 win  /* get total number of entries */
      all=result
      status 8 win  /* get number of dirs selected */
      seldirs=result
      n=1
      do i=1 to all
     getentry i
     dirname.n=result
     fileinfo '"'result'" /'
     parse var result '/' filesize '/' '/' type '/' select '/'
     if type>0&select&filesize=0 then
        n=n+1
     end
      dirsize.=0
      dirsecs.=0
      ndirs=n-1
      call readlist(0)
      end
   getsizes
   return


version:

   if entries=0 then
      thisfile='DOpus:Rexx/LhADir.dopus'
   toptext "Searching for version string..."
   address command 'Version >T:Version.temp' thisfile 'FILE FULL'
   call open('tempfile','T:Version.temp','r')
   topline=readln('tempfile')
   call close ('tempfile')
   delete 'T:Version.temp'
   return


cleanupdms:
   if exists("T:DIZ"portname) then
     delete 'T:DIZ'portname
   if exists("ENV:Device"portname) then
     delete 'ENV:Device'portname
  return

undms:
   if entries=0|upper(right(selected,4))~=='.DMS' then
      call quitit "No DMS file selected."


   /* Modified by Allan & Tommy */
   address command 'DOpus:DizExtract/DMSdiz >NIL: x T:DIZ'portname thisfile
   if ~exists("T:DIZ"portname) then
      address command 'SelectDevice >ENV:Device'portname' "Unpack to Device" "No File_ID.Diz File" CX CY LC=0 HC=79 SF=2 BPT=11 PS=' portname
   else
      address command 'SelectDevice >ENV:Device'portname' "Unpack to Device" T:DIZ'portname' FILE CX CY LC=0 HC=79 SF=2 BPT=11 PS=' portname
   if RC>0 then do
      call cleanupdms
      call quitit "No device selected..."
      end

   call open('temp','ENV:Device'portname,'r')
   drive=readln('temp')
   close('temp')
   call cleanupdms

/*
   drive.1='DF0:'
   /* drive.0='RAD:' */
   drive.0='FF0:'
   status 26 set drive.1
   status 27 set drive.0
   toptext thisfile
   request "Please insert disk and select"lf"destination drive for DMS file"
   dest=result
   busy on
   checkabort
   if result then
      call quitit "Aborted..."
*/

   /* address command 'Run >NIL: <NIL: DMS <NIL: >PIPE:dmsout WRITE' thisfile 'TO ' drive.dest ' NOTEXT' */
   address command 'Run >NIL: <NIL: DMS <NIL: >PIPE:dmsout WRITE' thisfile 'TO ' drive 'NOTEXT'
   address command 'Status >T:ProcessNo COMMAND=DMS'
   call open('temp','T:ProcessNo','r')
   process=readln('temp')
   close('temp')
   delete 'T:ProcessNo'
   busy on

   nomess=1
   errors=''
   buffer=''
   call open('dmsout','PIPE:dmsout','r')
   do until eof('dmsout')
      buffer=buffer||readch('dmsout',25)
      here=verify(buffer,'a0d'x,'m')
      if here>0 then do
     line=left(buffer,here-1)
     if nomess&left(line,7)=='No Disk' then do
        /* toptext "Insert disk in" drive.dest */
        toptext "Insert disk in" drive
        nomess=0
        end
     parse var line ' ' line
     buffer=substr(buffer,here+1)
     if pos('ERROR',upper(line))>0 then do
        errors=errors||lf||line
        beep
        busy on
        end
     if left(line,9)=='unPacking' then do
        toptext selected '-' line
        checkabort
        if result then do
           address command 'Break' process 'C'
           topline="Aborted..."
           end
        end
     end
      end
   call close('dmsout')
   if errors~=='' then do
      toptext thisfile
      notify "Error Report"||lf||errors
      end
   return


checklhadir:

   arg checkwin
   status 13 checkwin  /* get window path */
   winpath=result
   test=upper(winpath)
   cuthere=pos('.LHA/',test)
   if cuthere=0 then
      cuthere=pos('.LZH/',test)
   if cuthere=0 then
      cuthere=pos('.RUN/',test)
   lhadir=cuthere>0
   if lhadir then do
      lhafile=left(winpath,cuthere+3)
      lhasubdir=substr(winpath,cuthere+5)
      end
   return


lhaextract:

   status 8 win  /* get number of dirs selected */
   anydirs=result>0
   mustmove=anydirs&s_lhasubdir~==''
   if mustmove then
      destpath=winpath'LhADir'port'/'
   else
      destpath=winpath

   call open('actionfile','T:actionfile'port,'w')
   do i=1 to entries
      if type.i>0 then
     wild='/#?'
      else
     wild=''
      call writeln('actionfile','"'patch(s_lhasubdir||name.i)||wild'"')
      end
   call close('actionfile')

   if anydirs then
      lhacmd='x'
   else
      lhacmd='e -x2'
   toptext "Extracting from archive..."
   address command 'LhA' lhacmd '-q -a -C0 -Qo "'patch2(s_lhafile)'" "'destpath'" @T:actionfile'port
   problem=rc>0
   if problem then
      topline="Error while extracting from archive."
   else do
      topline="OK"
      if notmove then
     none
      end

   if mustmove then do
      do i=1 to entries
     move '"'winpath'LhADir'port'/'s_lhasubdir||name.i'" "'winpath'"'
     end
      delete '"'winpath'LhADir'port'"'
      end
   delete 'T:actionfile'port
   busy on
   return


lhaadd:

   mustcopy=upper(right(source,length(lhasubdir)))~==upper(lhasubdir)
   if mustcopy then do  /* all files must be copied to T: before they can be added */
      homedir='T:LhADir'port'/'
      call createdirs
      end
   else
      homedir=left(source,length(source)-length(lhasubdir))
   call open('actionfile','T:actionfile'port,'w')
   call writeln('actionfile','"'patch(homedir)'"')

   if s_lhadir then
      call writeln('actionfile','#?')
   else do
      do i=1 to entries
     call writeln('actionfile','"'patch(lhasubdir||name.i)'"')
     if mustcopy then do
        copy '"'source||name.i'" "T:LhADir'port'/'lhasubdir'"'
        busy on
        end
     end
      end
   call close('actionfile')

   if pos('.LZH/',test)>0 then
      method='-0'
   else
      method=''
   toptext "Adding to archive..."
   address command 'LhA r' method '-q -e -r -Qo "'patch2(lhafile)'" @T:actionfile'port
   problem=rc>0
   if problem then
      topline="Error while adding to archive."
   else do
      topline="OK"
      if notmove then
     none
      end
   delete 'T:actionfile'port
   if mustcopy|s_lhadir then
      delete 'T:LhADir'port
   busy on
   call swapactive
   listlha=1
   call showlhadir
   call swapactive
   return


lhalist:

   address command 'LhA >T:LhADir.list'port 'vv -N -Qw -Qo "'lhafile'"'
   if rc>0 then do
      setwintitle '"<Directory not available>"'
      call quitit "Error while listing archive."
      end
   return


getnextone:

   getnextselected
   selected=result
   if follow then
      scrolltoshow '"'selected'"'
   fileinfo '"'selected'" /'
   parse var result '/' '/' '/' filetype '/'
   return


getall:

   status 6 win  /* get total number of entries */
   all=result
   n=1
   do i=1 to all
      getentry i
      name.n=result
      fileinfo '"'result'" /'
      parse var result '/' '/' '/' type.n '/' select '/'
      if select then
     n=n+1
      if n>entries then
     leave
      end
   return


createdirs:

   parse arg subdir
   dirstocreate='T:LhADir'port'/'lhasubdir||subdir
   here=0
   do forever
      here=pos('/',dirstocreate,here+1)
      if here=0 then
     leave
      makedir '"'left(dirstocreate,here-1)'"'
      end
   busy on
   return


swapactive:

   otherwindow
   win=1-win
   return


showlhadir:

   status 13 win set '"'lhafile'/'lhasubdir'"'
   toptext "Listing archive..."  /* toptext obscures error message */
   setwintitle '"LhADir listed archive"'
   now=date('i')*86400+time('s')
   ndirs=0
   call readlist(1)
   return


readlist:

   arg show  /* showdir or getsizes? */
   if listlha|~exists('T:LhADir.list'port) then
      call lhalist
   call open('tempfile','T:LhADir.list'port,'r')
   nextline=readln('tempfile')
   parse var nextline 21 whicharc "':"
   if upper(whicharc)~==upper(lhafile) then do  /* it's another archive's list */
      call close('tempfile')
      call lhalist
      call open('tempfile','T:LhADir.list'port,'r')
      call readln('tempfile')
      end
   do 2
      call readln('tempfile')  /* waste these 2 lines */
      end

   compstr=upper(lhasubdir)
   complen=length(compstr)
   nextline=readln('tempfile')

   do forever

      name=nextline
      infoline=readln('tempfile')
      do while pos('% ',infoline)<22
     name=infoline
     infoline=readln('tempfile')
     end
      if name=='-------- ------- ----- --------- --------' then
     leave
      nextline=readln('tempfile')
      if left(nextline,1)==':' then do
     parse var nextline 3 comment
     nextline=readln('tempfile')
     end
      else
     comment=''

      if upper(left(name,complen))==compstr then do
     name=substr(name,complen+1)
     if name~==''&pos('"',name)=0 then do
        if pos('/',name)>0 then do  /* it's a dir */
           parse var name dirname '/'
           olddir=0
           do i=ndirs to 1 by -1
          if upper(dirname)==upper(dirname.i) then do
             olddir=1
             if ~show then do
            toptext winpath||name
            parse var infoline size . '% ' datestamp +18
            dirsize.i=dirsize.i+size
            seconds=convertdate(datestamp)
            if seconds>dirsecs.i then
               dirsecs.i=seconds
            end
             leave
             end
          end
           if show&~olddir then do  /* a new dir */
          ndirs=ndirs+1
          dirname.ndirs=dirname
          addfile '"'dirname'" 0 1' now '"" ----RWED 0 0'
          end
           end
        else  /* it's a file */
           if show then do
          parse var infoline size . '% ' datestamp +18 +1 atts .
          seconds=convertdate(datestamp)
          addfile '"'name'"' size '-1' seconds '"'comment'"' atts '0 0'
          end
        end
     end
      end
   call close('tempfile')
   if ~show then
      do i=1 to ndirs
     addfile '"'dirname.i'"' dirsize.i '1' dirsecs.i '"" ----RWED 0 0'
     selectfile '"'dirname.i'"'
     end
   displaydir
   return


convertdate:  /* convert a file's date stamp to seconds past 01-Jan-78 */

   parse arg day '-' month '-' year ' ' hours ':' minutes ':' seconds
   century=19+(year<78)
   month=pos(month,'  JanFebMarAprMayJunJulAugSepOctNovDec')/3
   month=right(month,2,'0')
   return seconds+minutes*60+hours*3600+date('i',century||year||month||day,'s')*86400


patch:  /* patch file names containing pattern matching tokens */

   parse arg patched
   pos=1
   do forever
      here=verify(substr(patched,pos),"*#?|%()[]~'",'m')
      if here=0 then
     leave
      pos=pos+here+1
      patched=insert("'",patched,pos-3)
      end
   do forever
      here=verify(substr(patched,pos),'@','m')
      if here=0 then
     leave
      pos=pos+here+1
      patched=insert("*",patched,pos-3)
      end
   return patched


patch2:  /* for LhA file names */

   parse arg patched
   pos=1
   do forever
      here=verify(substr(patched,pos),'*#?|%()[]~','m')
      if here=0 then
     leave
      pos=pos+here+1
      patched=insert("'",patched,pos-3)
      end
   do forever
      here=verify(substr(patched,pos),"@'",'m')
      if here=0 then
     leave
      pos=pos+here+1
      patched=insert("*",patched,pos-3)
      end
   return patched


syntax:

   call quitit "Syntax Error" rc"," errortext(rc) "in line" sigl"."


checkconfig:

   status 26
   okaystring=result
   status 27
   cancelstring=result

   query dirflags
   olddirflags=result
   if olddirflags<0 then  /* bug in DOpus? */
      olddirflags=256+olddirflags
   if bittst(d2c(olddirflags),5) then do
      request "The config setting 'Re-read changed buffers'"lf"must be switched off. Shall I do this for you?"
      if ~result then do
     remember  /* something to restore */
     call quitit "Error, config setting 'Re-read changed buffers' must be switched off."
     end
      modify dirflags olddirflags-32
      end

   remember                /* remember user settings */
   busy on
   query updateflags
   follow=bittst(d2c(result),1)        /* scroll window to follow operations? */
   modify updateflags 0            /* no progress indicator */
   query deleteflags
   askdelete=bittst(d2c(result),0)    /* ask before deleting? */
   modify deleteflags 8            /* don't ask when deleting internal */
   modify replaceflags 1        /* don't ask when replacing internal */
   modify iconflags 0            /* no icons please */
   query font 2                /* text viewer font */
   parse var result fontname '.font/' fontsize
   return


quitit:

   parse arg topline
   status 26 set okaystring        /* restore okay and */
   status 27 set cancelstring        /* cancel strings */
   restore                   /* restore user settings */
   if topline~=="" then
      toptext topline            /* display final message */
   if pos("Error",topline)>0 then
      beep                /* an error occurred */
   busy off                /* busy mouse pointer off */
   exit                    /* stop script here */